home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / setf-funs.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.1 KB  |  65 lines
  1. ;;; -*- Package: Kernel -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: setf-funs.lisp,v 1.2 91/05/08 15:57:49 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Stuff to automatically generate SETF functions for all the standard
  15. ;;; functions that are currently implemented with setf macros.
  16. ;;;
  17. (in-package "KERNEL")
  18.  
  19. (eval-when (compile eval)
  20.  
  21. (defun compute-one-setter (name type)
  22.   (let* ((args (second type))
  23.      (res (type-specifier
  24.            (single-value-type
  25.         (values-specifier-type (third type)))))
  26.      (arglist (loop repeat (1+ (length args)) collect (gensym))))
  27.     (cond
  28.      ((null (intersection args lambda-list-keywords))
  29.       `(defun (setf ,name) ,arglist
  30.      (declare ,@(mapcar #'(lambda (arg type)
  31.                 `(type ,type ,arg))
  32.                 arglist
  33.                 (cons res args)))
  34.      (setf (,name ,@(rest arglist)) ,(first arglist))))
  35.      ((ignore-errors (get-setf-method `(apply #',name args)))
  36.       `(defun (setf ,name) (newval &rest args)
  37.      (setf (apply #',name args) newval)))
  38.      (t
  39.       (warn "Hairy setf expander for function ~S." name)
  40.       nil))))
  41.        
  42.  
  43. (defmacro define-setters (packages &rest ignore)
  44.   (collect ((res))
  45.     (dolist (pkg packages)
  46.       (do-external-symbols (sym pkg)
  47.     (when (and (fboundp sym)
  48.            (eq (info function kind sym) :function)
  49.            (or (info setf inverse sym)
  50.                (info setf expander sym))
  51.            (not (member sym ignore)))
  52.       (let ((type (type-specifier (info function type sym))))
  53.         (assert (consp type))
  54.         (res `(declaim (inline (setf ,sym))))
  55.         (res (compute-one-setter sym type))))))
  56.     `(progn ,@(res))))
  57.  
  58. ); eval-when (compile eval)
  59.  
  60. (define-setters ("LISP")
  61.   ;; Have explicit definitions...
  62.   aref bit sbit
  63.   ;; Semantically silly...
  64.   getf apply ldb mask-field logbitp)
  65.